(* Yoann Padioleau
 *
 * Copyright (C) 2013 Facebook
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * version 2.1 as published by the Free Software Foundation, with the
 * special exception on linking described in file license.txt.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the file
 * license.txt for more details.
 *)
open Common
open Ast_fuzzy

(*****************************************************************************)
(* Prelude *)
(*****************************************************************************)
(* A few helpers function to build Ast_fuzzy tree from a list of tokens.
 * It factorizes the language-independent part of those AST fuzzy builder.
 *)

(*****************************************************************************)
(* Types *)
(*****************************************************************************)

type token_kind =
  (* for the fuzzy parser and sgrep/spatch fuzzy AST *)
  | LPar
  | RPar
  | LBrace
  | RBrace
  | LBracket
  | RBracket
  | LAngle
  | RAngle
  (* for the unparser helpers in spatch, and to filter
   * irrelevant tokens in the fuzzy parser
   *)
  | Esthet of esthet
  (* mostly for the lexer helpers, and for fuzzy parser *)
  (* less: want to factorize all those TH.is_eof to use that?
   * but extra cost? same for TH.is_comment?
   * todo: could maybe get rid of that now that we don't really use
   * berkeley DB and prefer Prolog, and so we don't need a sentinel
   * ast elements to associate the comments with it
   *)
  | Eof
  | Other

and esthet = Comment | Newline | Space

type 'tok hooks = { kind : 'tok -> token_kind; tokf : 'tok -> Tok.t }

exception Unclosed of string * Tok.t (* starting point *)

(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)
let char_of_token_kind = function
  | RAngle -> '>'
  | RBracket -> ']'
  | RBrace -> '}'
  | _ -> raise Impossible

(*****************************************************************************)
(* Entry point *)
(*****************************************************************************)

(*
 * less: I should also factorize with Parse_cpp.parse_fuzzy.
 * put here also generic parts of  token_views_of_xxx?
 *
 * less: check that it's consistent with the indentation?
 * less: more fault tolerance? if col == 0 and { then reset?
 *)

let mk_trees h xs =
  (* filter comment tokens *)
  let xs =
    xs
    |> List_.exclude (fun t ->
           let kind = h.kind t in
           match kind with
           | Esthet _
           | Eof ->
               true
           | _ -> false)
  in

  let rec consume x xs =
    match x with
    | tok when h.kind tok =*= LBrace ->
        let body, closing, rest = look_close RBrace x [] xs in
        (Ast_fuzzy.Braces (h.tokf x, body, h.tokf closing), rest)
    | tok when h.kind tok =*= LBracket ->
        let body, closing, rest = look_close RBracket x [] xs in
        (Ast_fuzzy.Bracket (h.tokf x, body, h.tokf closing), rest)
    | tok when h.kind tok =*= LAngle ->
        let body, closing, rest = look_close RAngle x [] xs in
        (Ast_fuzzy.Angle (h.tokf x, body, h.tokf closing), rest)
    | tok when h.kind tok =*= LPar ->
        let body, closing, rest = look_close_paren x [] xs in
        let body' = split_comma body in
        (Ast_fuzzy.Parens (h.tokf x, body', h.tokf closing), rest)
    | tok -> (Ast_fuzzy.Tok (Tok.content_of_tok (h.tokf tok), h.tokf x), xs)
  (*
    (match Ast.str_of_info (tokext tok) with
    | "..." -> Ast_fuzzy.Dots (tokext tok)
    | s when Ast_fuzzy.is_metavar s -> Ast_fuzzy.Metavar (s, tokext tok)
    | s -> Ast_fuzzy.Tok (s, tokext tok)
*)
  and aux xs =
    match xs with
    | [] -> []
    | x :: xs ->
        let x', xs' = consume x xs in
        x' :: aux xs'
  and look_close close_kind tok_start accbody xs =
    match xs with
    | [] ->
        raise
          (Unclosed
             ( spf "look_close '%c'" (char_of_token_kind close_kind),
               h.tokf tok_start ))
    | x :: xs -> (
        match x with
        | tok when h.kind tok =*= close_kind -> (List.rev accbody, x, xs)
        | _ ->
            let x', xs' = consume x xs in
            look_close close_kind tok_start (x' :: accbody) xs')
  (* todo? diff with look_close RPar ? *)
  and look_close_paren tok_start accbody xs =
    match xs with
    | [] -> raise (Unclosed ("look_close_paren", h.tokf tok_start))
    | x :: xs -> (
        match x with
        | tok when h.kind tok =*= RPar -> (List.rev accbody, x, xs)
        | _ ->
            let x', xs' = consume x xs in
            look_close_paren tok_start (x' :: accbody) xs')
  and split_comma xs =
    let rec aux acc xs =
      match xs with
      | [] -> if List_.null acc then [] else [ Either.Left (acc |> List.rev) ]
      | x :: xs -> (
          match x with
          | Ast_fuzzy.Tok (",", info) ->
              let before = acc |> List.rev in
              if List_.null before then aux [] xs
              else Either.Left before :: Either.Right info :: aux [] xs
          | _ -> aux (x :: acc) xs)
    in
    aux [] xs
  in
  aux xs

let mk_tokens hooks toks =
  toks |> List_.map (fun tok -> (hooks.kind tok, hooks.tokf tok))

(*****************************************************************************)
(* Visitor *)
(*****************************************************************************)

type visitor_out = trees -> unit

type visitor_in = {
  ktree : (tree -> unit) * visitor_out -> tree -> unit;
  ktrees : (trees -> unit) * visitor_out -> trees -> unit;
  ktok : (tok -> unit) * visitor_out -> tok -> unit;
}

let (default_visitor : visitor_in) =
  {
    ktree = (fun (k, _) x -> k x);
    ktok = (fun (k, _) x -> k x);
    ktrees = (fun (k, _) x -> k x);
  }

let (mk_visitor : visitor_in -> visitor_out) =
 fun vin ->
  let rec v_tree x =
    let k x =
      match x with
      | Braces (v1, v2, v3) ->
          let _v1 = v_tok v1 and _v2 = v_trees v2 and _v3 = v_tok v3 in
          ()
      | Parens (v1, v2, v3) ->
          let _v1 = v_tok v1
          and _v2 = OCaml.v_list (OCaml.v_either v_trees v_tok) v2
          and _v3 = v_tok v3 in
          ()
      | Angle (v1, v2, v3) ->
          let _v1 = v_tok v1 and _v2 = v_trees v2 and _v3 = v_tok v3 in
          ()
      | Bracket (v1, v2, v3) ->
          let _v1 = v_tok v1 and _v2 = v_trees v2 and _v3 = v_tok v3 in
          ()
      | Metavar v1 ->
          let _v1 = v_wrap v1 in
          ()
      | Dots v1 ->
          let _v1 = v_tok v1 in
          ()
      | Tok v1 ->
          let _v1 = v_wrap v1 in
          ()
    in
    vin.ktree (k, all_functions) x
  and v_trees a =
    let k xs =
      match xs with
      | [] -> ()
      | x :: xs ->
          v_tree x;
          v_trees xs
    in
    vin.ktrees (k, all_functions) a
  and v_wrap (_s, x) = v_tok x
  and v_tok x =
    let k _x = () in
    vin.ktok (k, all_functions) x
  and all_functions x = v_trees x in
  all_functions

(*****************************************************************************)
(* Map *)
(*****************************************************************************)

type map_visitor = { mtok : (tok -> tok) -> tok -> tok }

let (mk_mapper : map_visitor -> trees -> trees) =
 fun hook ->
  let rec map_tree = function
    | Braces (v1, v2, v3) ->
        let v1 = map_tok v1 and v2 = map_trees v2 and v3 = map_tok v3 in
        Braces (v1, v2, v3)
    | Parens (v1, v2, v3) ->
        let v1 = map_tok v1
        and v2 = List_.map (OCaml.map_of_either map_trees map_tok) v2
        and v3 = map_tok v3 in
        Parens (v1, v2, v3)
    | Angle (v1, v2, v3) ->
        let v1 = map_tok v1 and v2 = map_trees v2 and v3 = map_tok v3 in
        Angle (v1, v2, v3)
    | Bracket (v1, v2, v3) ->
        let v1 = map_tok v1 and v2 = map_trees v2 and v3 = map_tok v3 in
        Bracket (v1, v2, v3)
    | Metavar v1 ->
        let v1 = map_wrap v1 in
        Metavar v1
    | Dots v1 ->
        let v1 = map_tok v1 in
        Dots v1
    | Tok v1 ->
        let v1 = map_wrap v1 in
        Tok v1
  and map_trees v = List_.map map_tree v
  and map_tok v =
    let k v = v in
    hook.mtok k v
  and map_wrap (s, t) = (s, map_tok t) in
  map_trees

(*****************************************************************************)
(* Extractor *)
(*****************************************************************************)

let (toks_of_trees : trees -> Tok.t list) =
 fun trees ->
  let globals = ref [] in
  let hooks =
    { default_visitor with ktok = (fun (_k, _) i -> Stack_.push i globals) }
  in
  let vout = mk_visitor hooks in
  vout trees;
  List.rev !globals

(*****************************************************************************)
(* Abstract position *)
(*****************************************************************************)

let abstract_position_trees trees =
  let hooks = { mtok = (fun _k _i -> Tok.Ab) } in
  let mapper = mk_mapper hooks in
  mapper trees
